(DEFPROP EDITOR (
	EDITOR
	ERRMSG0
	ERRMSG1
	ERRMSG2
	ERRMSG3
	ERRMSG4
	ERRMSG5
	ERRMSG6
	NTH
	POS
	COPY
	CHOP
) EDITORFNS)

(DEFPROP EDITOR (
        TOP 
        UP
        LF
        RT
        RI
        RO
        LI
        RO
        P
) ATOMIC-EDIT-FNS)

(DEFPROP EDITOR (
	(I N X)
	(D N)
) LIST-EDIT-FNS)

(DEFUN EDITOR FEXPR (L)
  (PROG (FN TOP CE CHAIN COMMAND EFN)
    (SETQ FN (CAR L))
    (SETQ TOP (COPY (GET FN 'EXPR)))
    (COND ((NULL TOP)  (ERRMSG0) (RETURN 'NO-EDIT)))
    (SETQ CE TOP CHAIN NIL)
  EDLOOP
    (PRINT 'ε)
    (SETQ COMMAND (READ))
    (COND ((EQ COMMAND 'Q) (RETURN 'BYE) )
          ((EQ COMMAND 'OK) (RETURN (PUTPROP FN TOP 'EXPR)) )
          ((NUMBERP COMMAND) 
	   (COND ((OR (ATOM CE) (GREATERP COMMAND (LENGTH CE)))
                  (ERRMSG1) (GO EDLOOP)))
           (SETQ CHAIN (CONS (CONS COMMAND CE) CHAIN))
	   (SETQ CE (NTH CE COMMAND)) 
           (GO EDLOOP) )
          ((AND (ATOM COMMAND) (SETQ EFN (GET COMMAND 'ATOMIC-EDIT-FN)))
           (EVAL EFN)
           (GO EDLOOP) )
          ((AND (NOT (ATOM COMMAND)) (SETQ EFN (GET (CAR COMMAND) 'LIST-EDIT-FN)))
           (APPLY EFN (CDR COMMAND))
           (GO EDLOOP)) )
    (ERRMSG2)
    (GO EDLOOP) ))

;;; ATOMIC-EDIT-FNS

(DEFPROP TOP ;;;
  (PROG ()
    (SETQ CE TOP)
    (SETQ CHAIN NIL))
ATOMIC-EDIT-FN)

(DEFPROP UP  ;;;CE ← PARENT(CE)
  (PROG () 
    (COND ((NULL CHAIN) (RETURN (ERRMSG3))))
    (SETQ CE (CDAR CHAIN))
    (SETQ CHAIN (CDR CHAIN)) )
ATOMIC-EDIT-FN)

(DEFPROP LF ;;;MOVE LEFT
  (PROG (N)
    (COND ((NULL CHAIN) (RETURN (ERRMSG3))))
    (SETQ N (SUB1 (CAAR CHAIN)))
    (COND ((LESSP N 1) (RETURN (ERRMSG4))))
    (SETQ CE (NTH (CDAR CHAIN) N))
    (RPLACA (CAR CHAIN) N))
ATOMIC-EDIT-FN)

(DEFPROP RT ;;;MOVE RIGHT
  (PROG (N)
    (COND ((NULL CHAIN) (RETURN (ERRMSG3))))
    (SETQ N (ADD1 (CAAR CHAIN)))
    (COND ((GREATERP N (LENGTH (CDAR CHAIN))) (RETURN (ERRMSG5))))
    (SETQ CE (NTH (CDAR CHAIN) N))
    (RPLACA (CAR CHAIN) N))
ATOMIC-EDIT-FN)

(DEFPROP RI ;;;MOVE RIGHT PAREN IN 
  (PROG (CETMP POS)
    (COND ((NULL CHAIN) (RETURN (ERRMSG3))))
    (COND ((ATOM CE) (RETURN (ERRMSG6))))
    (SETQ CETMP (CONS NIL CE))
    (SETQ POS (POS (CDAR CHAIN) (CAAR CHAIN)))
    (RPLACD POS (CONS (CHOP CETMP) (CDR POS)))
    (RPLACA POS (SETQ CE (CDR CETMP))) );;; IN CASE CE CHOPPED TO NIL
ATOMIC-EDIT-FN)

(DEFPROP RO ;;;MOVE RIGHT PAREN OUT
  (PROG (CETMP POS POS1)
    (COND ((NULL CHAIN) (RETURN (ERRMSG3))))
    (COND ((AND (ATOM CE) (NOT (NULL CE))) (RETURN (ERRMSG6))))
    (SETQ POS (POS (CDAR CHAIN) (CAAR CHAIN)))
    (SETQ POS1 (CDR POS))
    (COND ((NULL POS1) (RETURN (ERRMSG5))))
    (SETQ CETMP (CONS NIL CE))
    (NCONC CETMP POS1)   ;;;MOVE RT(CE) TO END OF CE
    (RPLACD POS (CDR POS1))
    (RPLACD POS1 NIL)
    (RPLACA POS (SETQ CE (CDR CETMP))) ) ;;; IN CASE CE WAS NIL
ATOMIC-EDIT-FN)

(DEFPROP LI ;;;MOVE LEFT PAREN IN 
  (PROG (CETMP POS)
    (COND ((NULL CHAIN) (RETURN (ERRMSG3))))
    (COND ((ATOM CE) (RETURN (ERRMSG6))))
    (SETQ POS (POS (CDAR CHAIN) (CAAR CHAIN)))
    (RPLACD POS (CONS (CDR CE) (CDR POS)))
    (RPLACA POS (CAR CE))
    (SETQ CE (CDR CE))
    (RPLACA (CAR CHAIN) (ADD1 (CAAR CHAIN))) )
ATOMIC-EDIT-FN)

(DEFPROP LO ;;;MOVE LEFT PAREN OUT
  (PROG (CETMP POS)
    (COND ((NULL CHAIN) (RETURN (ERRMSG3))))
    (COND ((AND (ATOM CE) (NOT (NULL CE))) (RETURN (ERRMSG6))))
    (SETQ N (SUB1 (CAAR CHAIN)))
    (COND ((LESSP N 1) (RETURN (ERRMSG4))))
    (SETQ POS (POS (CDAR CHAIN) N))
    (RPLACD POS (CDDR POS))
    (RPLACA POS (CONS (CAR POS) CE)) 
    (RPLACA (CAR CHAIN) N)
    (SETQ CE (CAR POS)) )
ATOMIC-EDIT-FN)

(DEFPROP P  ;;;PRINT THE CE
  (PRINT CE)
ATOMIC-EDIT-FN)

(DEFPROP B  ;;;BREAK
  (BREAK EDITOR T)
ATOMIC-EDIT-FN)

;;; LIST-EDIT-FNS

(DEFPROP I  
  (LAMBDA (N X)
    (PROG (POS TMP)
      (COND ((LESSP N 0) (RETURN (ERRMSG2)))
	    ((EQ N 1) ;;; RESET CE AND POINTERS TO IT
	     (COND ((NULL CHAIN)(SETQ TOP (SETQ CE (CONS X CE))))
		   (T (RPLACA (POS (CDAR CHAIN) (CAAR CHAIN)) 
			      (SETQ CE (CONS X CE)))))))

      (SETQ POS (POS CE (SUB1 N)))
      (SETQ TMP (CONS X NIL))
      (RPLACD TMP (CDR POS))
      (RPLACD POS TMP)))
LIST-EDIT-FN)

(DEFPROP D
  (LAMBDA (N)
    (PROG (POS TMP)
      (COND ((LESSP N 0) (RETURN (ERRMSG2)))
	    ((EQ N 1) ;;; RESET CE AND POINTERS TO IT
	     (COND ((NULL CHAIN)(SETQ TOP (SETQ CE (CDR CE))))
		   (T (RPLACA (POS (CDAR CHAIN) (CAAR CHAIN)) 
			      (SETQ CE (CDR CE))))))
            ((GREATERP N (LENGTH CE)) (RETURN (ERRMSG2))))
      (SETQ POS (POS CE (SUB1 N)))
      (RPLACD POS (CDDR POS)) ))
LIST-EDIT-FN)
;;; AUXILIARY EDIT FNS

(DEFUN ERRMSG0 () (PRINT FN) (PRINC '| not an EXPR |))
(DEFUN ERRMSG1 () (PRINT COMMAND) (PRINC '| > length of CE |))
(DEFUN ERRMSG2 () (TERPRI) (PRINC '| Unknown command |))
(DEFUN ERRMSG3 () (TERPRI) (PRINC '| You are at the top |))
(DEFUN ERRMSG4 () (TERPRI) (PRINC '| You are at the left edge |))
(DEFUN ERRMSG5 () (TERPRI) (PRINC '| You are at the right edge |))
(DEFUN ERRMSG6 () (TERPRI) (PRINC '| CE is atomic |))

(DEFUN NTH (U N) 
  (COND ((AND (GREATERP N 1) (NOT (NULL (CDR U)))) (NTH (CDR U) (SUB1 N)))
	(T (CAR U)) ))

(DEFUN POS (U N) 
  (COND ((AND (GREATERP N 1) (NOT (NULL (CDR U)))) (POS (CDR U) (SUB1 N)))
	(T U) ))

(DEFUN COPY (X) (COND ((ATOM X) X) (T (CONS (COPY (CAR X)) (COPY (CDR X)))) ))


(DEFUN CHOP (U)
  (PROG (U1 U2)
    (SETQ U1 U)
  LOOP
    (SETQ U2 (CDR U1))
    (COND ((NULL (CDR U2)) (RPLACD U1 NIL) (RETURN (CAR U2))))
    (SETQ U1 U2)
    (GO LOOP) ))